perm filename TOTAL[PAT,LMM]1 blob
sn#058036 filedate 1973-08-09 generic text, type T, neo UTF8
(PROGN (LISPXPRIN1 (QUOTE "FILE CREATED ")
T)
(LISPXPRIN1 (QUOTE " 7-JAN-73 5:44:44")
T)
(LISPXTERPRI T))
(LISPXPRINT (QUOTE TOTALVARS)
T)
(RPAQQ
TOTALVARS
((FNS GETFILEC COLLECT FILEADD UNCOLLECT *MACRO *FILEADD
FULLEXPANSION CRPX GSETQ Y/N RECOLLECT GSET PUTPROP LF LC
QUIT GETFILE READDIR COUNTDOWN EXPANSION PRINTREC PRINTREC1
!RECORD FIXMACRO MACRO ANYTWICE CADRLAST CARLIST RECORD RECDO
COMPOSE COMPOSE1 COMPOSE2 COMPOSE3 COMPOSE4 ≠CONS ≠REPLACE
*FOR +NEXT VARNAME CONDIT SETIT INITL +PV GONEXTN | +TESTSET
NEGATE *IF THENCLAUSE LFSTRING LISTFILE LISTFILES LOADC @1 @2)
(VARS (CURRENTFILE NIL)
(NOCOLLECT NIL)
(EXTRAFNS NIL)
HOST)
(P (SETQ YESFNS USERWORDS))
[ADDVAL PRETTYMACROS
([RECORD (L)
(PROP RECORD L)
(P (RECORD (QUOTE L]
[LMMMAC (L)
(COMS *
(SUBST (GETD (QUOTE L))
(QUOTE DEF)
(QUOTE ((P (/PUTDQ L DEF)
(FIXMACRO (QUOTE L]
[!RECORD (L)
(PROP !RECORD L)
(P (!RECORD (QUOTE L]
[ADDVAL (VAR VAL)
(P (/SET (QUOTE VAR)
(UNION (QUOTE VAL)
VAR]
[EDITMAC (X)
(VARS X)
(P (EDITE X (QUOTE ((COMS (##]
[EDITMACRO (X)
(PROP EDITMACRO X)
(P (EDITE (GETP (QUOTE X)
(QUOTE EDITMACRO))
(QUOTE ((COMS (##]
(NEEDS (L)
(P (GETFILEC (QUOTE L]
(EDITMAC MACEXPAND)
(ADDVAL NOFNS (FOR IF))
(VARS (QUOTEFNS NIL))
(LMMMAC IF)
(LMMMAC FOR)
(LMMMAC REPLACE)
(ADVISE DEFINE LOAD)
(PROP LOGIN SRI-ARC)
(PROP LOGIN SU-AI)
(PROP LOGIN CASE-10)
(LMMMAC ≠QUOTE)))
(DEFINEQ
(GETFILEC
[LAMBDA (FIL)
(COND
((LISTP FIL)
(MAPC FIL (FUNCTION GETFILEC)))
(T (OR (AND [INFILEP (SETQ FIL (PACK (LIST (NAMEFIELD FIL)
".COM"]
(LOADC FIL))
(LOADC (NAMEFIELD FIL])
(COLLECT
[LAMBDA (FILE)
(GETFILE FILE)
(/SET (QUOTE CURRENTFILE)
FILE)
(/SET (QUOTE NOCOLLECT)
NIL)
FILE])
(FILEADD
[NLAMBDA (TYPE ITEM)
[COND
((ATOM TYPE)
(SETQ TYPE (LIST TYPE]
(*FILEADD TYPE (EVAL ITEM])
(UNCOLLECT
[LAMBDA NIL
(/SET (QUOTE NOCOLLECT)
T])
(*MACRO
[LAMBDA (L)
(PROG ((NOCOLLECT T))
(MAPC (SETQ L (DEFINE L))
(FUNCTION FIXMACRO)))
L])
(*FILEADD
[LAMBDA (TYPE ITEM)
(OR NOCOLLECT
(COND
((OR (EQ (CAR (QUOTE CURRENTFILE))
(QUOTE NOBIND))
(NOT CURRENTFILE))
(/SET (QUOTE EXTRAFNS)
(CONS (APPEND TYPE ITEM)
EXTRAFNS)))
(T (PROG (TYPEL VARSLIST (CURRENTFILE (GETFILE CURRENTFILE)))
[SETQ VARSLIST (CAR (CADR (GETP CURRENTFILE
(QUOTE FILE]
(COND
([EDITFINDP VARSLIST (APPEND TYPE
(LIST (QUOTE --)
ITEM
(QUOTE --]
(RETURN CURRENTFILE)))
(OR (AND [NOT (MEMBER TYPE (QUOTE ((RECORD)
(!RECORD)
(LMMMAC)
(EDITMACRO]
(NOT (CDR TYPE))
(SETQ TYPEL (ASSOC (CAR TYPE)
VARSLIST)))
(PROG1 (SETQ TYPEL TYPE)
(/NCONC1 VARSLIST TYPEL)))
(/NCONC1 TYPEL ITEM)
(/NCONC1 (GETP CURRENTFILE (QUOTE FILE))
ITEM)
(LIST CURRENTFILE])
(FULLEXPANSION
[LAMBDA (X)
(SETQ X (EXPANSION X))
(COND
[(CDR (GETP (CAR X)
(QUOTE CROPS)))
(CRPX (CADR X)
(GETP (CAR X)
(QUOTE CROPS]
(T X])
(CRPX
[LAMBDA (DEF XL)
(COND
((NOT XL)
DEF)
(T (CRPX (LIST (SELECTQ (CAR XL)
(A (QUOTE CAR))
(D (QUOTE CDR))
(HELP "CROPS PROP"))
DEF)
(CDR XL])
(GSETQ
[NLAMBDA (GSETVAR Y)
(GSET GSETVAR (EVAL Y])
(Y/N
[NLAMBDA (DEFAULT)
(PROG ((CNT (ITIMES DWIMWAIT 2))
R)
[COND
((ATOM DEFAULT)
(SETQ DEFAULT (SELECTQ DEFAULT
[Y (QUOTE ((Y . ES)
(N . O]
(QUOTE ((N . O)
(Y . ES]
LP (COND
((MINUSP (SETQ CNT (SUB1 CNT)))
(PRIN1 "...")
(PRIN1 (SETQ R (CAAR DEFAULT)))
(GO GOTIT))
((NOT (READP T))
(DISMISS 500)
(GO LP)))
RETRY
(SETQ R (PEEKC T))
GOTIT
(CLEARBUF T T)
(COND
((SETQ R (ASSOC R DEFAULT))
(PRIN1 (CDR R)
T)
(TERPRI T))
(T (PRIN1 "π")
(GO RETRY)))
(LINBUF NIL)
(RETURN (CAR R])
(RECOLLECT
[LAMBDA NIL
(/SET (QUOTE NOCOLLECT)
NIL])
(GSET
[LAMBDA (X Y)
(FILEADD VARS X)
(/SET X Y])
(PUTPROP
[LAMBDA (NAM IND VAL)
(*FILEADD (LIST (QUOTE PROP)
IND)
NAM)
(PUT NAM IND VAL])
(LF
[LAMBDA (FILES)
(MAPC FILES (FUNCTION LOAD])
(LC
[LAMBDA (FILES)
(OR FILES (SETQ FILES (READDIR "*.COM")))
(MAPC FILES (FUNCTION (LAMBDA (FILE)
(LOAD (PACK (LIST FILE ".COM"])
(QUIT
[LAMBDA NIL
(MAKEFILES '(FAST RC))
(LOGOUT])
(GETFILE
[LAMBDA (FILE)
[COND
((LISTP FILE)
(MAPCAR FILE (FUNCTION GETFILE)))
((MEMBER FILE FILELST))
((AND (INFILEP FILE)
(PRIN1 "DO YOU WANT ME TO LOAD ")
(PRIN1 FILE)
(PRIN1 " ?")
(EQ (Y/N N)
(QUOTE Y)))
(LOAD FILE))
(T [/PUT FILE (QUOTE FILE)
(LIST (/RPLACA (PACK (LIST FILE "FNS")))
(/RPLACA (PACK (LIST FILE "VARS"))
(COPY (QUOTE ((FNS)
(VARS]
(/SET (QUOTE FILELST)
(CONS FILE FILELST]
FILE])
(READDIR
[LAMBDA (STR)
(PROG (FIL RESLT HELPCLOCK (CNT 20))
(TENEX (CONCAT "DIR " STR " ,
OU D.D;0
"))
(INFILE (QUOTE D.D))
(READ (QUOTE D.D))
LP [SETQ FIL (NLSETQ (READ (QUOTE D.D]
(COND
((NOT FIL)
(RETURN RESLT)))
(SETQ FIL (NAMEFIELD (CAR FIL)))
(COND
((NOT FIL)
(GO LP)))
(PRIN1 FIL)
(PRIN1 " ? ")
[COND
((EQ (Y/N Y)
(QUOTE Y))
(SETQ RESLT (CONS FIL RESLT]
(GO LP])
(COUNTDOWN
[LAMBDA (SEXP ALST)
(COND
((NULL ALST)
NIL)
((LISTP SEXP)
(COUNTDOWN (CDR SEXP)
(COUNTDOWN (CAR SEXP)
ALST)))
(T (PROG (X)
(SETQ X (ASSOC SEXP ALST))
(RETURN (COND
((NULL X)
ALST)
((EQP (CDR X)
1)
NIL)
(T (RPLACD X (SUB1 (CDR X)))
ALST])
(EXPANSION
[LAMBDA (FORM)
(PROG [(MACVAL (GETP (CAR FORM)
(QUOTE MACRO]
(COND
((NOT MACVAL)
FORM)
((MEMB (CAR MACVAL)
(QUOTE [LAMBDA NLAMBDA]))
(CONS MACVAL (CDR FORM)))
[(AND (CAR MACVAL)
(ATOM (CAR MACVAL)))
(EVALA (CADR MACVAL)
(LIST (CONS (CAR MACVAL)
(CDR FORM]
(T (SUBPAIR (CAR MACVAL)
(CDR FORM)
(CADR MACVAL])
(PRINTREC
[LAMBDA (REC VAL)
(PROG ((NAME REC))
(COND
([OR (LISTP REC)
(SETQ REC (GETP REC (QUOTE RECORD]
(PRINTREC1 REC VAL))
((SETQ REC (GETP NAME (QUOTE !RECORD)))
(PRIN1 (CAR VAL))
(PRINT (QUOTE :))
(PRINTREC1 REC (CDR VAL)))
(T (PRIN1 NAME)
(PRIN1 "?")
(PRINT VAL])
(PRINTREC1
[LAMBDA (REC VAL)
(COND
((NULL REC)
NIL)
((ATOM REC)
(PRIN1 REC)
(PRIN1 " = ")
(PRINT VAL))
(T (PRINTREC1 (CAR REC)
(CAR VAL))
(PRINTREC1 (CDR REC)
(CDR VAL])
(!RECORD
[LAMBDA (NAME FIELD)
[PROG ((NOCOLLECT T))
(COND
(FIELD (/PUT NAME (QUOTE !RECORD)
FIELD))
[(SETQ FIELD (GETP NAME (QUOTE !RECORD]
(T (ERROR "EMPTY RECORD" NAME)))
[*MACRO (LIST (LIST (PACK (LIST NAME "?"))
(LIST (QUOTE LAMBDA)
(QUOTE (IDVAR))
(LIST (QUOTE EQ)
(QUOTE (CAR IDVAR))
(KWOTE NAME]
[*MACRO
(LIST
(LIST
NAME
(SUBST
NAME
(QUOTE NAME)
(SUBST FIELD (QUOTE FIELD)
(QUOTE (NLAMBDA RECORDVAR
(SETQ RECORDVAR
(REMOVE (QUOTE IS)
(REMOVE (QUOTE =)
RECORDVAR)))
(EVAL (COMPOSE RECORDVAR
(QUOTE ((ID . NAME) .
FIELD]
(RECDO FIELD (QUOTE (CDR X]
(FILEADD !RECORD NAME)
NAME])
(FIXMACRO
[LAMBDA (FN)
(SELECTQ
(FNTYP FN)
[EXPR (/PUT FN (QUOTE MACRO)
(COND
((ANYTWICE FN (CADR (GETD FN))
(CADDR (GETD FN)))
(GETD FN))
(T (CDR (GETD FN]
[FEXPR
(AND (EQ (CAAR (LAST (GETD FN)))
(QUOTE EVAL))
(/PUT FN (QUOTE MACRO)
(LIST (QUOTE L)
(CONS [CONS (QUOTE LAMBDA)
(CADRLAST (CDR (GETD FN]
(CARLIST (CADR (GETD FN))
(QUOTE L]
[EXPR*(OR (ANYTWICE FN NIL (CADDR (GETD FN)))
(/PUT FN (QUOTE MACRO)
(GETD FN]
[FEXPR*(AND (EQ (CAAR (LAST (GETD FN)))
(QUOTE EVAL))
(/PUT FN (QUOTE MACRO)
(LIST (CADR (GETD FN))
(CONS (QUOTE PROGN)
(CADRLAST (CDDR (GETD FN]
(ERROR FN "FIXMACRO CAN'T"])
(MACRO
[LAMBDA (L)
(MAPCAR (*MACRO L)
(FUNCTION (LAMBDA (X)
(FILEADD LMMMAC X])
(ANYTWICE
[LAMBDA (FN ARGS SEXP)
(NOT (COUNTDOWN SEXP (CONS (CONS FN 1)
(MAPCAR ARGS (FUNCTION (LAMBDA (X)
(CONS X 2])
(CADRLAST
[LAMBDA (L)
(COND
((NULL (CDR L))
(LIST (CADAR L)))
(T (CONS (CAR L)
(CADRLAST (CDR L])
(CARLIST
[LAMBDA (L DEF)
(CONS (LIST (QUOTE CAR)
DEF)
(AND (CDR L)
(CARLIST (CDR L)
(LIST (QUOTE CDR)
DEF])
(RECORD
[LAMBDA (NAME FIELD)
(PROG ((NOCOLLECT T))
(COND
(FIELD (/PUT NAME (QUOTE RECORD)
FIELD))
[(SETQ FIELD (GETP NAME (QUOTE RECORD]
(T (ERROR "EMPTY RECORD" NAME)))
[*MACRO
(LIST (LIST NAME
(SUBST FIELD (QUOTE FIELD)
(QUOTE (NLAMBDA RECORDVAR
(SETQ RECORDVAR
(REMOVE (QUOTE IS)
(REMOVE (QUOTE =)
RECORDVAR)))
(EVAL (COMPOSE RECORDVAR
(QUOTE FIELD]
(RECDO FIELD (QUOTE X)))
(FILEADD RECORD NAME)
NAME])
(RECDO
[LAMBDA (FORMAT DEF)
(COND
((NULL FORMAT)
NIL)
((LISTP FORMAT)
(RECDO (CAR FORMAT)
(LIST (QUOTE CAR)
DEF))
(RECDO (CDR FORMAT)
(LIST (QUOTE CDR)
DEF)))
(T
(MACRO
(LIST
(LIST FORMAT
(SUBST DEF (QUOTE DEF)
(QUOTE (NLAMBDA RECORDFIELDVAR
(SETQ RECORDFIELDVAR
(REMOVE (QUOTE OF)
RECORDFIELDVAR))
(EVAL (SUBST (COND
((NULL (CDR
RECORDFIELDVAR))
(CAR RECORDFIELDVAR))
(T RECORDFIELDVAR))
(QUOTE X)
(QUOTE DEF])
(COMPOSE
[LAMBDA (L FIELD)
(SELECTQ (CAR L)
[FROM (COND
((ATOM (CADR L))
(COMPOSE1 L FIELD (CADR L)))
(T (LIST (LIST (QUOTE LAMBDA)
(QUOTE (COMPOSEVAR))
(COMPOSE1 L FIELD (QUOTE COMPOSEVAR)
))
(CADR L]
[DFROM (COND
[(ATOM (CADR L))
(COND
((EQ [CADR (SETQ FIELD (COMPOSE1
L FIELD (CADR L]
(CADR L))
FIELD)
(T (LIST (QUOTE PROGN)
FIELD
(CADR L]
(T (LIST (LIST (QUOTE LAMBDA)
(QUOTE (COMPOSEVAR))
(COMPOSE1 L FIELD (QUOTE
COMPOSEVAR))
(QUOTE COMPOSEVAR))
(CADR L]
(COMPOSE1 L FIELD (QUOTE COMPOSEVAR])
(COMPOSE1
[LAMBDA (L FIELD DEF)
(PROG (K)
(COND
((SETQ K (COMPOSE2 L FIELD DEF))
(CAR K))
(T (COMPOSE3 L FIELD DEF])
(COMPOSE2
[LAMBDA (L FIELD DEF)
(COND
((NULL FIELD)
NIL)
[(ATOM FIELD)
(AND (MEMB FIELD L)
(SELECTQ (CAR L)
[DFROM (LIST (LIST (SELECTQ (CAR DEF)
(CAR (QUOTE RPLACA))
(QUOTE RPLACD))
(CADR DEF)
(SUBST DEF (QUOTE **)
(GET L FIELD]
(LIST (SUBST DEF (QUOTE **)
(GET L FIELD]
[(EQ (CAR FIELD)
(QUOTE ID))
(LIST (KWOTE (CDR FIELD]
(T
(PROG (KA KD)
(SETQ KD (COMPOSE2 L (CDR FIELD)
(LIST (QUOTE CDR)
DEF)))
(SETQ KA (COMPOSE2 L (CAR FIELD)
(LIST (QUOTE CAR)
DEF)))
(AND (NULL KA)
(NULL KD)
(RETURN NIL))
(RETURN
(LIST
(SELECTQ (CAR L)
(DFROM (≠REPLACE (CAR KA)
(CAR KD)))
(≠CONS [COND
(KA (CAR KA))
(T (COMPOSE1 L (CAR FIELD)
(LIST (QUOTE CAR)
DEF]
(COND
(KD (CAR KD))
(T (COMPOSE1 L (CDR FIELD)
(LIST (QUOTE CDR)
DEF])
(COMPOSE3
[LAMBDA (L FIELD DEF)
(SELECTQ (CAR L)
(FROM DEF)
(COMPOSE4 FIELD])
(COMPOSE4
[LAMBDA (FIELD)
(COND
((NULL FIELD)
NIL)
[(ATOM FIELD)
([LAMBDA (X)
(COND
(X (KWOTE X]
(GETP FIELD (QUOTE RECDEFAULT]
(T (≠CONS (COMPOSE4 (CAR FIELD))
(COMPOSE4 (CDR FIELD])
(≠CONS
[LAMBDA (CARPART CDRPART)
(COND
[(OR (EQ (CAR CDRPART)
(QUOTE LIST))
(NOT (CAR CDRPART)))
(CONS (QUOTE LIST)
(CONS CARPART (CDR CDRPART]
(T (LIST (QUOTE CONS)
CARPART CDRPART])
(≠REPLACE
[LAMBDA (CARPART CDRPART)
(COND
((NULL CARPART)
CDRPART)
((NULL CDRPART)
CARPART)
((AND (EQ (CAR CARPART)
(QUOTE RPLACA))
(EQ (CAR CDRPART)
(QUOTE RPLACD))
(EQUAL (CADR CARPART)
(CADR CDRPART)))
(LIST (QUOTE RPLACD)
CARPART
(CADDR CDRPART)))
(T (LIST (QUOTE PROGN)
CARPART CDRPART])
(*FOR
[LAMBDA (L)
(PROG (N FV PV EPILOGUE PROLOGUE DOFORM DOTYPE VAR RANGE LST
VARNEXT NEXT NEXTS N2 N3 INIT TESTSET)
(SETQ N 1)
FORLOOP
[AND (EQ (CAR L)
(QUOTE NEW))
(+PV (CAR (SETQ L (CDR L]
(SETQ VAR (CAR L))
(SETQ RANGE (CADDR L))
(+NEXT (SETQ VARNEXT (VARNAME "NEXT")))
(SELECTQ
(CADR L)
[IN (+TESTSET (CONDIT (NEGATE (INITL (+PV (SETQ LST
(VARNAME "LIST")
))
RANGE))
(GONEXTN)))
(+TESTSET (SETIT VAR (LIST (QUOTE CAR)
LST)))
(+NEXT (SETIT LST (LIST (QUOTE CDR)
LST]
[ON (+TESTSET (CONDIT (NEGATE VAR)
(GONEXTN)))
(+NEXT (SETIT (INITL VAR RANGE)
(LIST (QUOTE CDR)
VAR]
[:=[SETQ N2 (COND
((ATOM (CADR RANGE))
(CADR RANGE))
(T (INITL (+PV (VARNAME "MAX"))
(CADR RANGE]
(SETQ N3 (COND
[(CDDR RANGE)
(COND
((ATOM (CADDR RANGE))
(CADDR RANGE))
(T (INITL (+PV (VARNAME "INC"))
(CADDR RANGE]
((AND (NUMBERP (CAR RANGE))
(NUMBERP (CADR RANGE))
(GREATERP (CAR RANGE)
(CADR RANGE)))
-1)
(T 1)))
(INITL VAR (CAR RANGE))
(+TESTSET
(CONDIT
(COND
[(NOT (NUMBERP N3))
(LIST (QUOTE COND)
(LIST (LIST (QUOTE MINUSP)
N3)
(LIST (QUOTE ILESSP)
VAR N2))
(LIST T (LIST (QUOTE
OR (LIST (QUOTE ZEROP)
N3)
(LIST (QUOTE GREATERP)
VAR N2]
((MINUSP N3)
(LIST (QUOTE ILESSP)
VAR N2))
(T (LIST (QUOTE IGREATERP)
VAR N2)))
(GONEXTN)))
(+NEXT (SETIT VAR (LIST (QUOTE IPLUS)
VAR N3]
(IS (+TESTSET (SETIT VAR RANGE)))
(ERROR "INVALID FOR TYPE"))
(SETQ L (CDDDR L))
ASLOOP
(SELECTQ (CAR L)
(AS (SETQ L (CDR L))
(SETQ NEXTS (APPEND NEXTS NEXT))
(SETQ NEXT)
(GO FORLOOP))
((IF WHEN)
(+TESTSET (CONDIT (NEGATE (CADR L))
(LIST (QUOTE GO)
VARNEXT)))
(SETQ L (CDDR L)))
(UNTIL (+NEXT (CONDIT (CADR L)
(GONEXTN)))
(SETQ L (CDDR L)))
(WHILE (+TESTSET (CONDIT (NEGATE (CADR L))
(GONEXTN)))
(SETQ L (CDDR L)))
(GO FORTEST))
(GO ASLOOP)
FORTEST
(SETQ PROLOGUE (APPEND TESTSET (LIST (| "LOOP" N))
INIT PROLOGUE))
[SETQ EPILOGUE (CONS (| "NEXT" N)
(APPEND (REVERSE NEXT)
(REVERSE NEXTS)
(CONS (LIST (QUOTE GO)
(| "LOOP" N))
EPILOGUE]
[SETQ TESTSET (SETQ INIT (SETQ NEXT (SETQ NEXTS]
(COND
((EQ (CAR L)
(QUOTE FOR))
(SETQ L (CDR L))
(SETQ N (ADD1 N))
(GO FORLOOP)))
(SETQ DOTYPE (CAR L))
(SETQ DOVAL (CAR (LAST L)))
(+PV (QUOTE FOR-VALUE))
(SETQ FV (SELECTQ DOTYPE
((APPEND LIST NCONC)
(QUOTE (CAR FOR-VALUE)))
(QUOTE FOR-VALUE)))
[SETQ DOFORM
(SELECTQ
DOTYPE
[(AND OR)
(CONDIT (LIST (SELECTQ DOTYPE
(AND (INITL (QUOTE FOR-VALUE)
T)
(QUOTE NOT))
(QUOTE PROGN))
(SETIT (QUOTE FOR-VALUE)
DOVAL))
(QUOTE (RETURN FOR-VALUE]
((PROGN PROG2)
(SETIT (QUOTE FOR-VALUE)
DOVAL))
(DO DOVAL)
(SETIT (QUOTE FOR-VALUE)
(CONS (OR [CDR (ASSOC DOTYPE
(QUOTE ((LIST . TCONC)
(NCONC . LCONC)
(XLIST . CONS)
(APPEND . LCONC]
DOTYPE)
(SELECTQ DOTYPE
((LIST NCONC)
(LIST (QUOTE FOR-VALUE)
DOVAL))
(APPEND (LIST (QUOTE FOR-VALUE)
(LIST (QUOTE APPEND)
DOVAL)))
(LIST DOVAL (QUOTE FOR-VALUE]
[COND
((EQ (CAR (SETQ L (CDR L)))
(QUOTE FIRST))
(INITL (QUOTE FOR-VALUE)
(SELECTQ
DOTYPE
[(LIST APPEND NCONC)
(COND
((NLISTP (CADR L))
(LIST [QUOTE (LAMBDA (FOR% INIT)
(CONS FOR% INIT
(LAST FOR% INIT]
(CADR L)))
(T (CONS (CADR L)
(LAST (CADR L]
(CADR L)))
(SETQ L (CDDR L)))
((MEMB DOTYPE (QUOTE (PLUS IPLUS TIMES ITIMES MAX MIN)))
(INITL (QUOTE FOR-VALUE)
(CDR (ASSOC DOTYPE (QUOTE ((PLUS . 0)
(MAX . -99999)
(MIN . 99999)
(IPLUS . 0)
(TIMES . 1)
(ITIMES . 1]
(RETURN (CONS (QUOTE PROG)
(CONS PV (APPEND INIT (REVERSE PROLOGUE)
(REVERSE (CDR (REVERSE L)))
(LIST DOFORM)
EPILOGUE
(LIST (QUOTE RETURN)
(LIST (QUOTE RETURN)
FV])
(+NEXT
[LAMBDA (ITEM)
(SETQ NEXT (CONS ITEM NEXT))
ITEM])
(VARNAME
[LAMBDA (STR)
(PACK (LIST STR "*" VAR])
(CONDIT
[LAMBDA (PRD DO)
(LIST (QUOTE COND)
(LIST PRD DO])
(SETIT
[LAMBDA (VAR VAL)
(AND (NOT (EQ VAR VAL))
(LIST (QUOTE SETQ)
VAR VAL])
(INITL
[LAMBDA (VAR VAL)
(SETQ INIT (CONS (SETIT VAR VAL)
INIT))
VAR])
(+PV
[LAMBDA (VAR)
(SETQ PV (CONS VAR PV))
VAR])
(GONEXTN
[LAMBDA NIL
(LIST (QUOTE GO)
(COND
((EQP N 1)
(QUOTE RETURN))
(T (PACK (LIST "NEXT*" (SUB1 N])
(|
[LAMBDA (STR VAL)
(PACK (LIST STR "*" N])
(+TESTSET
[LAMBDA (ITEM)
(SETQ TESTSET (CONS ITEM TESTSET))
ITEM])
(NEGATE
[LAMBDA (EXP)
(SELECTQ (CAR EXP)
((NOT NULL)
(CADR EXP))
(LIST (QUOTE NOT)
EXP])
(*IF
[LAMBDA (L)
(AND L (CONS [CONS (CAR L)
(COND
((NOT (EQ (CADR L)
(QUOTE
THEN)))
(ERROR L "NO CORRESPONDING THEN IN IF"))
(T (SETQ L (CDDR L))
(THENCLAUSE]
(COND
((NULL L)
NIL)
((EQ (CAR L)
(QUOTE
ELSEIF))
(*IF (CDR L)))
((EQ (CAR (SETQ L (CDR L)))
(QUOTE IF))
(*IF (CDR L)))
(T (LIST (CONS T (THENCLAUSE])
(THENCLAUSE
[LAMBDA NIL
(COND
([OR (NULL L)
(MEMB (CAR L)
(QUOTE (ELSE
ELSEIF]
(LIST NIL))
[[OR (NOT (CDR L))
(MEMB (CADR L)
(QUOTE (ELSE
ELSEIF]
(PROG1 (LIST (CAR L))
(SETQ L (CDR L]
(T (CONS (CAR L)
(PROGN (SETQ L (CDR L))
(THENCLAUSE])
(LFSTRING
[LAMBDA (FIL)
(CONCAT "FTP
" "C " [OR (CAR (NLSETQ HOST))
(PROGN (PRIN1 "HOST? " T)
(SETQ HOST (READ T]
"
LOG "
[OR (GETP HOST (QUOTE LOGIN))
(PUT HOST (QUOTE LOGIN)
(PROGN (PRIN1 "LOGIN (ENTER STRING):")
(READ T]
"
TE
SE " FIL "≠
" FIL "
QUIT
QUIT
"])
(LISTFILE
[LAMBDA (FIL)
(BKSYSBUF (LFSTRING FIL))
(KFORK (SUBSYS])
(LISTFILES
[LAMBDA (FL)
(COND
((NOT FL)
(SETQ FL NOTLISTEDFILES)))
[COND
((ATOM FL)
(SETQ FL (LIST FL]
(MAPC FL (FUNCTION (LAMBDA (FIL)
(LISTFILE (NAMEFIELD FIL))
(SETQ NOTLISTEDFILES (REMOVE (NAMEFIELD FIL)
NOTLISTEDFILES])
(LOADC
[LAMBDA (FIL)
(AND (PRIN1 "DO YOU WANT ME TO LOAD ")
(PRIN1 FIL)
(PRIN1 " ? ")
(SELECTQ (Y/N ((Y . ES)
(N . O)
(P . ROP)
(C . OM)))
(Y (LOAD FIL))
(P (LOAD FIL (QUOTE PROP)))
[C (LOAD (PACK (LIST FIL ".COM"]
NIL])
(@1
[LAMBDA (X M)
(COND
((OR (NULL X)
(NUMBERP X)
(STRINGP X)
(EQ X T))
X)
((SETQ M (@2 X M))
M)
(T (LIST (QUOTE QUOTE)
X])
(@2
[LAMBDA (X N)
(COND
((ATOM X)
NIL)
[(EQ (CAR X)
(QUOTE ≠))
(COND
((ATOM (CDR X))
(CDR X))
((NULL (CDDR X))
(LIST (QUOTE LIST)
(CADR X)))
(T ([LAMBDA (D E)
(COND
[(EQ (CAR D)
(QUOTE LIST))
(CONS (QUOTE LIST)
(CONS E (CDR D]
(T (LIST (QUOTE CONS)
E D]
(@1 (CDDR X))
(CADR X]
((NULL (CDR X))
(COND
((SETQ N (@2 (CAR X)
N))
(LIST (QUOTE LIST)
N))
(T NIL)))
(T (PROG (M)
(SETQ M (@2 (CAR X)
N))
(SETQ N (@2 (CDR X)
N))
(COND
((AND (NULL M)
(NULL N))
(RETURN NIL)))
[COND
((AND (NULL M)
(SETQ M (CAR X))
(NOT (NUMBERP M))
(NOT (EQ M T))
(NOT (STRINGP M)))
(SETQ M (LIST (QUOTE QUOTE)
M]
(RETURN (COND
[(EQ (CAR N)
(QUOTE LIST))
(CONS (CAR N)
(CONS M (CDR N]
(T (LIST (QUOTE CONS)
M
(COND
((AND (NULL N)
(SETQ N (CDR X))
(NOT (NUMBERP N))
(NOT (EQ N T)))
(LIST (QUOTE QUOTE)
N))
(T N])
)
(RPAQ CURRENTFILE NIL)
(RPAQ NOCOLLECT NIL)
(RPAQ EXTRAFNS NIL)
(RPAQQ HOST SU-AI)
(SETQ YESFNS USERWORDS)
(/SET
(QUOTE PRETTYMACROS)
(UNION
[QUOTE ([RECORD (L)
(PROP RECORD L)
(P (RECORD (QUOTE L]
[LMMMAC (L)
(COMS *
(SUBST (GETD (QUOTE L))
(QUOTE DEF)
(QUOTE ((P (/PUTDQ L DEF)
(FIXMACRO (QUOTE L]
[!RECORD (L)
(PROP !RECORD L)
(P (!RECORD (QUOTE L]
[ADDVAL (VAR VAL)
(P (/SET (QUOTE VAR)
(UNION (QUOTE VAL)
VAR]
[EDITMAC (X)
(VARS X)
(P (EDITE X (QUOTE ((COMS (##]
[EDITMACRO (X)
(PROP EDITMACRO X)
(P (EDITE (GETP (QUOTE X)
(QUOTE EDITMACRO))
(QUOTE ((COMS (##]
(NEEDS (L)
(P (GETFILEC (QUOTE L]
PRETTYMACROS))
[RPAQQ MACEXPAND (M MACEXPAND (IF (GETP (## 1)
(QUOTE MACRO))
((I : (EXPANSION (##]
[EDITE MACEXPAND (QUOTE ((COMS (##]
(/SET (QUOTE NOFNS)
(UNION (QUOTE (FOR IF))
NOFNS))
(RPAQ QUOTEFNS NIL)
[/PUTDQ IF (NLAMBDA IF-EXPRESSION (EVAL (CONS (QUOTE COND)
(*IF IF-EXPRESSION]
(FIXMACRO (QUOTE IF))
[/PUTDQ FOR (NLAMBDA FOR-EXPRESSION (EVAL (*FOR FOR-EXPRESSION]
(FIXMACRO (QUOTE FOR))
[/PUTDQ REPLACE (NLAMBDA (REPLACE1 REPLACE2)
(SETQ REPLACE1 (FULLEXPANSION REPLACE1))
(EVAL (LIST (SELECTQ (CAR REPLACE1)
(CAR (QUOTE RPLACA))
(CDR (QUOTE RPLACD))
(HELP "REPLACE CAN'T"
(LIST REPLACE1
REPLACE2)))
(CADR REPLACE1)
REPLACE2]
(FIXMACRO (QUOTE REPLACE))
(DEFLIST(QUOTE(
[DEFINE (NIL (AFTER NIL (MAPC !VALUE (FUNCTION (LAMBDA (FN)
(FILEADD
FNS FN]
[LOAD (NIL (BIND NIL ((NOCOLLECT T]
))(QUOTE READVICE))
(READVISE DEFINE LOAD)
(DEFLIST(QUOTE(
(SRI-ARC "SU-HP ARPA 3")
))(QUOTE LOGIN))
(DEFLIST(QUOTE(
(SU-AI "1,LMM")
))(QUOTE LOGIN))
(DEFLIST(QUOTE(
(CASE-10 "NETWORK NETUSE 75")
))(QUOTE LOGIN))
[/PUTDQ ≠QUOTE (NLAMBDA (QUOTED-EXPRESSION)
(EVAL (@1 QUOTED-EXPRESSION]
(FIXMACRO (QUOTE ≠QUOTE))
STOP